home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / XLISP 3.0a1 / PP.LSP < prev    next >
Text File  |  1995-03-11  |  6KB  |  243 lines
  1. ;;; hacking by mh, 11/14/94
  2.  
  3. ;;; Macros must come before first usage:
  4.  
  5. (define-macro (pp-push *item *stack)
  6.   `(set! ,*stack (cons ,*item ,*stack)) )
  7.  
  8.  
  9. (define-macro (pp-pop *stack)
  10.   `(let ((top* (car ,*stack)))
  11.      (set! ,*stack (cdr ,*stack))
  12.      top*) )
  13.  
  14.  
  15.  
  16.  
  17. ;+
  18. ;               PP 1.0 : (C) Copyright 1985 by Gregory Frascadore
  19. ;
  20. ;   This software may be copied, modified, and distributed to others as long
  21. ;   as it is not sold for profit, and as long as this copyright notice is
  22. ;   retained intact. For further information contact the author at:
  23. ;               frascado%umn-cs.CSNET   (on CSNET)
  24. ;               75106,662               (on CompuServe)
  25. ;-
  26.  
  27. ;+
  28. ;                               PP 1.0
  29. ; DESCRIPTION
  30. ;   PP is a function for producing pretty-printed XLISP code. Version 1.0
  31. ;   works with XLISP 1.4 and may work with other versions of XLISP or other
  32. ;   lisp systems.
  33. ;
  34. ; UPDATE HISTORY
  35. ;   Version 1.0 - Original version, 11 April 1985 by Gregory Frascadore.
  36. ;
  37. ;-
  38.  
  39. ;+
  40. ; pp
  41. ;   This function pretty-prints an s-expression.
  42. ;
  43. ; format
  44. ;   (pp <expr> [<sink>] )
  45. ;
  46. ;       <expr>  the expression to print.
  47. ;       <sink>  optional. the sink to print to. defaults to
  48. ;                   *standard-output*
  49. ;       <maxlen> the threshold that pp uses to determine when an expr
  50. ;                   should be broken into several lines. The smaller the
  51. ;                   value, the more lines are used. Defaults to 45 which
  52. ;                   seems reasonable and works well too.
  53. ;-
  54.  
  55.  
  56. (set! pp-stack* nil
  57.       pp-istack* nil
  58.       pp-currentpos* nil
  59.       pp-sink* nil
  60.       pp-maxlen* nil)
  61.  
  62. (define (pp *expr &optional (*sink *standard-output*) (*maxlen 45))
  63.    (fluid-let ((pp-stack* nil)
  64.                (pp-istack* '(0))
  65.                (pp-currentpos* 0)
  66.                (pp-sink* *sink)
  67.                (pp-maxlen* *maxlen))
  68.       (pp-newline)
  69.       (pp-expr *expr)
  70.       (values)))
  71.  
  72.  
  73. (define (pp-expr *expr)
  74.    (cond ((pair? *expr)
  75.             (pp-list *expr) )
  76.  
  77.          (else (pp-write *expr)) ) )
  78.  
  79.  
  80. ;+
  81. ; pp-list
  82. ;   Pretty-print a list expression.
  83. ;       IF <the write-size length of *expr is less than pp-maxlen*>
  84. ;           THEN print the expression on one line,
  85. ;       ELSE
  86. ;       IF <the car of the expression is an atom>
  87. ;           THEN print the expression in the following form:
  88. ;                   "(atom <item1>
  89. ;                          <item2>
  90. ;                           ...
  91. ;                          <itemn> )"
  92. ;       ELSE
  93. ;       IF <the car of the expression is a list>
  94. ;           THEN print the expression in the following form:
  95. ;                   "(<list1>
  96. ;                     <item2>
  97. ;                       ...
  98. ;                     <itemn> )"
  99. ;
  100. ;-
  101.  
  102.  
  103. (define (pp-list *expr)
  104.    (cond ((< (write-size *expr) pp-maxlen*)
  105.             (pp-write *expr) )
  106.  
  107.          ((atom? (car *expr))
  108.             (case (car *expr)
  109.               ((define lambda named-lambda)
  110.                (pp-pushmargin (+ pp-currentpos* 2))
  111.                (pp-start)
  112.                (pp-write (car *expr))
  113.                (pp-display " "))
  114.               (else
  115.                (pp-start)
  116.                (pp-write (car *expr))
  117.                (pp-display " ")
  118.                (pp-pushmargin)))
  119.             (pp-rest (cdr *expr))
  120.             (pp-popmargin)
  121.             (pp-finish) )
  122.  
  123.          (else
  124.             (pp-start)
  125.             (pp-pushmargin)
  126.             (pp-rest *expr)
  127.             (pp-popmargin)
  128.             (pp-finish) ) ) )
  129.  
  130. ;+
  131. ; pp-rest
  132. ;   pp-expr each element of a list and do a pp-newline after every call to
  133. ;   pp-expr except the last.
  134. ;-
  135.  
  136. #|
  137. (define (pp-rest *rest)
  138.    (do* ((item* *rest (cdr item*)))
  139.         ((null? item*))
  140.             (pp-expr (car item*))
  141.             (if (not (null? (cdr item*))) (pp-newline)) ) )
  142. |#
  143.  
  144. (define (pp-rest *rest)
  145.   (let loop ((item* *rest))
  146.     (unless (null? item*)
  147.       (if (atom? item*)
  148.         (begin
  149.           (pp-display ".")
  150.           (pp-newline)
  151.           (pp-expr item*))
  152.         (begin
  153.           (pp-expr (car item*))
  154.           (if (not (null? (cdr item*))) (pp-newline))
  155.           (loop (cdr item*)))))))
  156.  
  157. ;+
  158. ; pp-newline
  159. ;   Print out a newline character and indent to the current margin setting
  160. ;   which is maintained at the top of the pp-istack. Note that is the
  161. ;   current top of the pp-stack* is a ")" we push a " " so that we will know
  162. ;   to print a space before closing any parenthesis which were started on a
  163. ;   different line from the one they are being closed on.
  164. ;-
  165.  
  166. (define (pp-newline)
  167.    (if (eqv? ")" (pp-top pp-stack*)) (pp-push " " pp-stack*))
  168.  
  169.    (newline pp-sink*)
  170.    (spaces (pp-top pp-istack*) pp-sink*)
  171.    (set! pp-currentpos* (pp-top pp-istack*)) )
  172.  
  173. ;+
  174. ; pp-finish
  175. ;   Print out the closing ")". If the top of the pp-stack* has a " " on it,
  176. ;   then print out the space, then the ")" , and then pop both off the stack.
  177. ;-
  178.  
  179. (define (pp-finish)
  180.    (cond ((eqv? ")" (pp-top pp-stack*))
  181.             (pp-display ")") )
  182.  
  183.          (else
  184.             (pp-display " )")
  185.             (pp-pop pp-stack*) ) )
  186.  
  187.    (pp-pop pp-stack*) )
  188.  
  189. ;;#|
  190.  
  191. ;+
  192. ; pp-start
  193. ;   Start printing a list. ie print the "(" and push a ")" on the pp-stack*
  194. ;   so that pp-finish knows to print a ")" when closing an list.
  195. ;-
  196.  
  197. (define (pp-start)
  198.    (pp-display "(")
  199.    (pp-push ")" pp-stack*) )
  200.  
  201. ;+
  202. ; pp-display
  203. ;   Prints out an expr without any quotes and updates the pp-currentpos*
  204. ;   pointer so that we know where on the line the cursor is at.
  205. ;-
  206.  
  207. (define (pp-display *expr)
  208.     (set! pp-currentpos* (+ pp-currentpos* (display-size *expr)))
  209.     (display *expr pp-sink*) )
  210.  
  211. ;+
  212. ; pp-write
  213. ;   Does the same thing as pp-write, except that the expr is printed with
  214. ;   quotes if needed. Hence pp-write uses write-size to calc expr length instead
  215. ;   of display-size.
  216. ;-
  217.  
  218.  
  219. (define (pp-write *expr)
  220.     (set! pp-currentpos* (+ pp-currentpos* (write-size *expr)))
  221.     (write *expr pp-sink*) )
  222.  
  223. (define (pp-top *stack) (car *stack))
  224.  
  225.  
  226. (define (pp-pushmargin &optional (new-margin pp-currentpos*))
  227.    (pp-push new-margin pp-istack*) )
  228.  
  229.  
  230. (define (pp-popmargin)
  231.    (pp-pop pp-istack*) )
  232.  
  233. #|
  234. (define (spaces n f)
  235.     (dotimes (x n) (write-char 32 f)))
  236. |#
  237.  
  238. (define (spaces n f)
  239.   (let loop ((i 0))
  240.     (if (< i n)
  241.       (begin
  242.         (write-char #\space f)
  243.     (loop (1+ i))))))